Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue26/pagectrl/PAGECTL2.PAS

Pascal/Delphi Source File | 1997-09-02 | 5.9 KB | 222 lines

//Tabsheet can't draw buttons in bottom or right positions
//Use TColorPageCtrl.TabVisible instead of
//  TTabSheet.TabVisible or TTabSheet.Visible

unit PageCtl2;

interface

uses
  Windows, Messages, CommCtrl, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ComCtrls, StdCtrls, ExtCtrls;

type
  TTabVPosition = (tvpNone, tvpLeft, tvpRight);
  TPageControlStyle = (pcsStandard, pcsOwnerDraw);

  TODPageControl2 = class(TPageControl)
  private
    FCanvas       : TCanvas;
    FOnDrawItem   : TDrawItemEvent;
    FTabButtons   : Boolean;
    FStyle        : TPageControlStyle;
    FTabVPosition : TTabVPosition;

    procedure DrawItem(Index: Integer; ARect: TRect;
      State: TOwnerDrawState);

  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;

    procedure SetStyle(Value: TPageControlStyle);
    procedure SetTabButtons(Value: Boolean);
    procedure SetTabVPosition(Value: TTabVPosition);

    procedure CNDrawItem(var Msg: TWMDrawItem);
      message cn_DrawItem;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DefaultDrawTab(Index: Integer; ARect: TRect;
      State: TOwnerDrawState); virtual;
    property Canvas: TCanvas read FCanvas;

  published
    property Style: TPageControlStyle
      read FStyle write SetStyle default pcsStandard;
    property TabButtons: Boolean
      read FTabButtons write SetTabButtons default False;
    property TabVPosition: TTabVPosition
      read FTabVPosition write SetTabVPosition default tvpNone;
    property OnDrawItem: TDrawItemEvent
      read FOnDrawItem write FOnDrawItem;
  end;

procedure Register;

implementation

//Delphi 2 and C++ Builder 1 don't have some
//of the necessary constants or properties
{$ifdef Ver90}
  {$define OldCommCtrl}
{$endif}
{$ifdef Ver93}
  {$define OldCommCtrl}
{$endif}
{$ifdef OldCommCtrl}
const
  tcs_Right = 2;
  tcs_Bottom = 2;
  tcs_Vertical = $80;
{$endif}

constructor TODPageControl2.Create(AOwner: TComponent);
begin
  inherited;
  FTabButtons   := False;
  FStyle        := pcsStandard;
  FTabVPosition := tvpNone
end;

destructor TODPageControl2.Destroy;
begin
  //cleanup after ourselves
  if Assigned(FCanvas) then
    FCanvas.Free;
  inherited
end;

procedure TODPageControl2.DrawItem(Index: Integer; ARect: TRect;
  State: TOwnerDrawState);
begin
  if Assigned(FOnDrawItem) then
    FOnDrawItem(Self, Index, ARect, State)
  else
    DefaultDrawTab(Index, ARect, State)
end;

procedure TODPageControl2.CreateParams(var Params: TCreateParams);
const
  ButtonStyle: array[Boolean] of LongInt = (0, tcs_Buttons);
  OwnStyle: array[Boolean] of LongInt = (0, tcs_OwnerDrawFixed);
  VerticalStyle: array[TTabVPosition] of LongInt =
    (0, tcs_Vertical, tcs_Right or tcs_Vertical);
begin
  inherited;
  with Params do
  begin
    if VerticalStyle[FTabVPosition] <> 0 then
      Style := Style and not tcs_Bottom;
    //When ScrollOpposite is set True, buttons don't get drawn
    //Also, the control is unable to do buttons properly
    //When tabs are at bottom or right
    FTabButtons := FTabButtons and not
      {$ifndef OldCommCtrl}
      ScrollOpposite and not
      {$endif}
      ({$ifndef OldCommCtrl}(TabPosition = tpBottom) or {$endif}
       (FTabVPosition = tvpRight));
    Style := Style or ButtonStyle[FTabButtons]
                   or OwnStyle[FStyle = pcsOwnerDraw]
                   or VerticalStyle[FTabVPosition];
   end;
end;

procedure TODPageControl2.CreateWnd;
begin
  inherited;
  //Force a realign and repositioning of tabsheets
  //this is needed for the new vertical and horizontal styles
  PostMessage(Handle, wm_Size, size_Restored,
    MakeLong(Width, Height));
  Realign
end;

procedure TODPageControl2.SetStyle(Value: TPageControlStyle);
begin
  if Value <> FStyle then
  begin
    FStyle := Value;
    RecreateWnd;
  end;
end;

procedure TODPageControl2.SetTabButtons(Value: Boolean);
begin
  if Value <> FTabButtons then
  begin
    FTabButtons := Value;
    //Can't have buttons at bottom or right of control
    //The Windows control can't handle it...
    if Value then
    begin
      if FTabVPosition = tvpRight then
        FTabVPosition := tvpNone;
      {$ifndef OldCommCtrl}
      if TabPosition = tpBottom then
        TabPosition := tpTop;
      {$endif}
    end;
    RecreateWnd;
  end;
end;

procedure TODPageControl2.SetTabVPosition(Value: TTabVPosition);
begin
  if  Value <> FTabVPosition then
  begin
    //When tabs are left/right, they turn into multiline
    //automatically so we'd better set the MultiLine property
    FTabVPosition := Value;
    if Value <> tvpNone then
      MultiLine := True;
    RecreateWnd;
  end;
end;

procedure TODPageControl2.CNDrawItem(var Msg: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  if not Assigned(FCanvas) then
    FCanvas := TCanvas.Create;
  with Msg.DrawItemStruct^ do
  begin
    //The low byte of ItemState is the bitmap that our set requires
    State := TOwnerDrawState(WordRec(Word(ItemState)).Lo);
    FCanvas.Handle := hDC;
    FCanvas.Font   := Font;
    FCanvas.Brush  := Brush;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State);
    FCanvas.Handle := 0;
  end;
end;

procedure TODPageControl2.DefaultDrawTab(Index: Integer;
  ARect: TRect; State: TOwnerDrawState);
var
  S: String;
  X, Y: Integer;
begin
  //Do a bit of default drawing when the
  //component user is'nt doing it
  FCanvas.FillRect(ARect);
  S := Pages[Index].Caption;
  X := (ARect.Right + ARect.Left - FCanvas.TextWidth(S)) div 2;
  Y := (ARect.Bottom + ARect.Top + 4 - FCanvas.TextHeight(S)) div 2;
  //Active tab has text _slightly_ higher
  if odSelected in State then
    Dec(Y, 3);
  FCanvas.TextOut(X, Y, S);
end;

procedure Register;
begin
  RegisterComponents('Clinic', [TODPageControl2]);
end;

end.